home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / ASTRNOMY / HEAT0_1.ZIP / HEATDOS.FOR < prev    next >
Text File  |  1993-11-09  |  60KB  |  1,976 lines
  1.  
  2.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  3.      integer   iolog,lincnt
  4.      logical   scrnop,diskop,opened,ltrltr
  5.      character line(1:79)
  6.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  7.      integer maxit, iterno
  8.      real    accfac, cnvrg, bigres
  9.      logical finis,divrg
  10.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  11.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  12.      integer shape,size,vsize,inshp,insize,ivsize,
  13.      +       thick,hthick,vthick,square,circle,rctngl
  14.      logical solid, skewed
  15.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  16.      real    intrnt, lowert, uppert, prcnt, mint, maxt
  17.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  18.      real    temper (1:79,1:79)
  19.      integer tmpshp(1:79,1:8)
  20.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  21.       logical answer, Quit
  22.       character ch
  23.  
  24.       call init
  25.       call initio
  26.       call initbs
  27.       call initit
  28.       call initsh
  29. 10    continue
  30.       call clrscr
  31.       Quit = .FALSE.
  32.       print *, ' Enter'
  33.       print *, ' <S> To Solve Heat Problem'
  34.       print *, ' <P> To Plot Output to Disk or Screen'
  35.       print *, ' <L> To List Numerical Data to Disk or Screen'
  36.       print *, ' <Q> To Quit'
  37.       call rdchar (Ch)
  38.       IF (Ch .eq. 'S' .or. Ch .eq. 's') THEN
  39.      call SOLVE
  40.       ELSE IF (Ch .eq. 'P' .or. Ch .eq. 'p') THEN
  41.      call PLOT
  42.       ELSE IF (Ch .eq. 'L' .or. Ch .eq. 'l') THEN
  43.      call LIST
  44.       ELSE IF (Ch .eq. 'Q' .or. Ch .eq. 'q') THEN
  45.      Quit = .TRUE.
  46.       ELSE IF (Ch .eq. '|' .or. Ch .eq. '~') THEN
  47.      call wrtmsh
  48.       ELSE
  49.      call WRONG
  50.       END IF
  51.       IF ( Quit .eqv. .FALSE. ) GO TO 10
  52.       call ENDOPT (answer)
  53.       IF (answer .eqv. .FALSE.) GO TO 10
  54.       END
  55.  
  56.       SUBROUTINE SOLVE
  57.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  58.      integer maxit, iterno
  59.      real    accfac, cnvrg, bigres
  60.      logical finis,divrg
  61.       integer iter
  62.       logical answer
  63.  
  64.       IF (finis .eqv. .FALSE.) THEN 
  65.      call finopt(answer)
  66.      IF (answer .eqv. .TRUE.) finis = .TRUE.
  67.       END IF
  68.       call readin
  69.       call initlz
  70.       IF (maxit .eq. 0) return
  71.       IF (finis .eqv. .TRUE.) THEN
  72.      iterno = 0
  73.      finis  = .FALSE.
  74.       END IF
  75. 15    continue
  76.       do 20 iter = 1, maxit
  77.      iterno = iterno + 1
  78.      call clrscr
  79.      print *,' Iteration step number ',iterno, '    of ',maxit
  80.      call itrate
  81.      IF ( bigres .lt. cnvrg ) THEN
  82.         finis = .TRUE.
  83.         call beep(2)
  84.         call clrscr
  85.         call wcvrg
  86.         Return
  87.      END IF
  88. 20    continue
  89. 30    continue
  90.       finis = .FALSE.
  91.       call beep(2)
  92.       call clrscr
  93.       call wncvrg
  94.       call conopt (answer)
  95.       IF (answer .eqv. .TRUE.) GO TO 15
  96.       END
  97.  
  98.       SUBROUTINE readin
  99.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  100.      integer maxit, iterno
  101.      real    accfac, cnvrg, bigres
  102.      logical finis,divrg
  103.       logical answer
  104.  
  105.       IF (finis .eqv. .FALSE.) THEN
  106.      call gtiter
  107.      return
  108.       END IF
  109. 10    continue
  110.       call clrscr
  111.       call wrbas
  112.       call writer
  113.       call wrshp
  114.       call okopt  (answer)
  115.       IF (answer .eqv. .TRUE.) GO TO 90
  116.       call gtbas
  117.       call gtiter
  118.       call gtshp
  119.       GO TO 10
  120. 90    continue
  121.       END 
  122.  
  123.       SUBROUTINE initlz
  124.       intrinsic nint, min, max
  125.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  126.      integer maxit, iterno
  127.      real    accfac, cnvrg, bigres
  128.      logical finis,divrg
  129.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  130.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  131.      integer shape,size,vsize,inshp,insize,ivsize,
  132.      +       thick,hthick,vthick,square,circle,rctngl
  133.      logical solid, skewed
  134.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  135.      real intrnt, lowert, uppert, prcnt, mint, maxt
  136.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  137.      real temper (1:79,1:79)
  138.      integer tmpshp(1:79,1:8)
  139.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  140.       integer row,col,rowe,midcol
  141.       real edget,incr,w
  142.  
  143.       IF (finis .eqv. .FALSE.) return
  144.       call initts
  145.       call initmp
  146.       mint = min(lowert,uppert,intrnt)
  147.       maxt = max(lowert,uppert,intrnt)
  148.       midcol = (size+1)/2
  149. 5     continue
  150.       GO TO (10,15,10) shape
  151.       print *, ' Shape value = ',shape
  152. 10    continue
  153.       call mkrect(1,1,size,vsize,els,ers)
  154.       GO TO 20
  155. 15    continue
  156.       call mkrnd (1,1,size,els,ers)
  157. 20    continue
  158.       IF (solid .eqv. .TRUE.) GO TO 40
  159.       GO TO (25,30,25)inshp
  160. 25    continue
  161.       call mkrect(hthick,vthick,insize,ivsize,ils,irs)
  162.       GO TO 35
  163. 30    continue
  164.       call mkrnd (hthick,vthick,insize,ils,irs)
  165. 35    continue
  166. 40    continue
  167.       call tstskw
  168.       call mkwall
  169.       do 50 col = tmpshp(1,els), midcol
  170.      temper(1,col) = uppert
  171.      temper(1,size-col+1) = uppert
  172. 50    continue   
  173.       w     = vsize * (100 - prcnt) * .01
  174.       rowe  = nint(w) 
  175.       IF (rowe .lt. 2) THEN
  176.      rowe = 1
  177.      GO TO 61
  178.       END IF
  179.       incr  = (uppert - lowert)/rowe
  180.       edget = uppert
  181.       do 60 row = 2, rowe
  182.      edget = edget - incr
  183.       do 55 col = tmpshp(row,els),midcol
  184.      temper(row,col) = edget
  185.      temper(row,size-col+1) = edget
  186. 55    continue
  187. 60    continue
  188. 61    continue
  189.       do 70 row = rowe+1,vsize
  190.       do 65 col = tmpshp(row,els),midcol
  191.      temper(row,col) = lowert
  192.      temper(row,size-col+1) = lowert
  193. 65    continue
  194. 70    continue
  195.       IF (solid .eqv. .TRUE.) GO TO 90
  196.       do 80 row = vthick,vthick+ivsize-1
  197.       do 75 col = tmpshp(row,ils),tmpshp(row,irs)
  198.      temper(row,col) = intrnt
  199. 75    continue
  200. 80    continue
  201. 90    continue
  202.       END
  203.  
  204.       SUBROUTINE itrate 
  205.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  206.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  207.      integer shape,size,vsize,inshp,insize,ivsize,
  208.      +       thick,hthick,vthick,square,circle,rctngl
  209.      logical solid, skewed
  210.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  211.      integer maxit, iterno
  212.      real    accfac, cnvrg, bigres
  213.      logical finis,divrg
  214.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  215.      real    temper (1:79,1:79)
  216.      integer tmpshp(1:79,1:8)
  217.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  218.       integer row,col,colm,midcol
  219.  
  220.       bigres = 0
  221.       midcol = (size+1)/2
  222.       IF (skewed .eqv. .TRUE.) GO TO 30
  223.       do 20 row = 2,vsize-1
  224.       do 10 col = tmpshp(row,wlb),midcol
  225.      call comput(row,col)
  226.      colm = size-col+1
  227.      temper(row,colm) = temper(row,col)
  228. 10    continue
  229. 20    continue
  230.       return
  231. 30    continue
  232.       do 50 row = 2,vsize-1
  233.       do 40 col = tmpshp(row,wlb),midcol
  234.      call comput(row,col)
  235.      colm = size-col+1
  236.      call comput(row,colm)
  237. 40    continue  
  238. 50    continue
  239.       END
  240.  
  241.       SUBROUTINE comput (row,col)                                         
  242.       intrinsic max,abs
  243.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  244.      integer maxit, iterno
  245.      real    accfac, cnvrg, bigres
  246.      logical finis,divrg
  247.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  248.      real    intrnt, lowert, uppert, prcnt, mint, maxt
  249.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  250.      real temper (1:79,1:79)
  251.      integer tmpshp(1:79,1:8)
  252.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  253.       real tempt
  254.       logical answer
  255.       integer row,col
  256.  
  257.       call inwall(row,col,answer)
  258.       IF (answer .eqv. .FALSE.) return
  259.       tempt = (0.25 * accfac) *
  260.      +        (temper(row+1,col) + temper(row-1,col) +
  261.      +         temper(row,col+1) + temper(row,col-1)) +
  262.      +        ((1.0 - accfac) * temper(row, col))
  263.       bigres = max(bigres,abs(tempt-temper(row,col)))
  264.       temper(row,col)=tempt
  265.       END
  266.  
  267.       SUBROUTINE plot
  268.       intrinsic abs, mod
  269.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  270.      integer   iolog,lincnt
  271.      logical   scrnop,diskop,opened,ltrltr
  272.      character line(1:79)
  273.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  274.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  275.      integer shape,size,vsize,inshp,insize,ivsize,
  276.      +       thick,hthick,vthick,square,circle,rctngl
  277.      logical solid, skewed
  278.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  279.      real intrnt, lowert, uppert, prcnt, mint, maxt
  280.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  281.      real temper (1:79,1:79)
  282.      integer tmpshp(1:79,1:8)
  283.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  284.       integer row, col, index
  285.       real tincr
  286.       logical answer
  287.       character*1 blank, letter(1:17)
  288.      parameter ( blank = ' ' )
  289.  
  290.       call initlt(letter)
  291.       call ltropt(ltrltr)
  292.       call gtioop(answer)
  293.       IF (answer .eqv. .FALSE.) return
  294.       tincr = abs(maxt-mint)/17
  295.       call clrscr              
  296.       lincnt = 0
  297.       do 30 row = 1, vsize
  298.      call initln
  299.       do 20 col = tmpshp(row,els),tmpshp(row,ers)
  300.      call onwall(row,col,answer)
  301.      IF (answer .eqv. .FALSE.) THEN
  302.         line(col) = blank
  303.      ELSE 
  304.      +   IF (temper(row,col) .le. mint) THEN
  305.         index = 1
  306.         line(col) = letter(index)
  307.      ELSE 
  308.      +   IF (temper(row,col) .ge. maxt) THEN
  309.         index = 17
  310.         line(col) = letter(index)
  311.      ELSE                              
  312.         index = ((temper(row,col)-mint)/tincr)+1.0
  313.         IF ((ltrltr .eqv. .FALSE.) .and. (mod(index,2) .eq. 0)) THEN
  314.            line(col) = blank
  315.         ELSE 
  316.            line(col) = letter(index)
  317.         END IF
  318.      END IF
  319. 20    continue
  320.       IF (scrnop .eqv. .TRUE.) THEN
  321.       IF (lincnt .ge. 20) THEN
  322.          call conopt (answer)
  323.          IF (answer .eqv. .FALSE.) GO TO 50
  324.          call clrscr
  325.          lincnt = 0
  326.       END IF
  327.       lincnt = lincnt + 1
  328.       print '(1x,79a1)', line
  329.       END IF
  330.       IF ((diskop .eqv. .TRUE.) .and. (opened .eqv. .TRUE.))
  331.      +   write (iolog,'(1x,79a1)') line
  332. 30    continue
  333. 50    continue
  334.       call wrltrs(letter,maxt,mint,tincr)
  335.       IF (opened .eqv. .TRUE.) call cldisk
  336.       END
  337.  
  338.       SUBROUTINE LIST 
  339.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  340.      integer   iolog,lincnt
  341.      logical   scrnop,diskop,opened,ltrltr
  342.      character line(1:79)
  343.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  344.      integer maxit, iterno
  345.      real    accfac, cnvrg, bigres
  346.      logical finis,divrg
  347.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  348.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  349.      integer shape,size,vsize,inshp,insize,ivsize,
  350.      +       thick,hthick,vthick,square,circle,rctngl
  351.      logical solid, skewed
  352.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  353.      real temper (1:79,1:79)
  354.      integer tmpshp(1:79,1:8)
  355.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  356.       integer row,rowb,rowe,col,colb,cole
  357.       logical answer
  358.  
  359.       call rdlist
  360.       call gtlmts(rowb,colb,rowe,cole)
  361.       call gtioop (answer)
  362.       IF (answer .eqv. .FALSE.) return
  363.       IF (opened .eqv. .TRUE.) THEN
  364.      do 20 row = rowb,rowe
  365.      do 10 col = colb,cole
  366.         call onwall(row,col,answer)
  367.         IF (answer .eqv. .TRUE.) THEN
  368.            write (iolog,'(I3,I3,f11.5)') row, col, temper(row,col)
  369.         END IF
  370. 10       continue      
  371. 20       continue
  372.       call cldisk
  373.       END IF
  374.       IF (scrnop .eqv. .TRUE.) THEN
  375.      call clrscr
  376.      lincnt = 0
  377.      do 70 row = rowb,rowe
  378.      do 60 col = colb,cole
  379.      IF (lincnt .ge. 20) THEN
  380.         call conopt (answer)
  381.         IF (answer .eqv. .FALSE.) GO TO 90
  382.         call clrscr
  383.         lincnt = 0
  384.      END IF
  385.      call onwall(row,col,answer)
  386.      IF (answer .eqv. .TRUE.) THEN
  387.         IF (lincnt .ge. 20) THEN
  388.            call conopt (answer)
  389.            IF (answer .eqv. .FALSE.) GO TO 90
  390.            call clrscr
  391.            lincnt = 0
  392.         END IF
  393.         lincnt = lincnt + 1
  394.         print *,' ',row,col,temper(row,col)
  395.      END IF
  396. 60       continue
  397. 70       continue
  398.       END IF
  399. 90    continue
  400.       IF (scrnop .eqv. .TRUE.) call prentr
  401.       END
  402.  
  403.       SUBROUTINE OpDskI
  404.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  405.      integer   iolog,lincnt
  406.      logical   scrnop,diskop,opened,ltrltr
  407.      character line(1:79)
  408.       character*50 filenm
  409.       logical answer,unfmt
  410.  
  411.       unfmt = .FALSE.
  412.       print *,' Opening Input File'
  413.       GO TO 10      
  414.       ENTRY OpDskO
  415.       IF (diskop .eqv. .FALSE.) THEN
  416.      print *, ' Cannot open disk for output',
  417.      +      ' if the disk option is not set.'
  418.      opened = .FALSE.
  419.      return
  420.       END IF
  421.       print *, ' W A R N I N G ! ! !   W A R N I N G ! ! !'
  422.       print *, ' If the file already exists it WILL BE OVERWRITTEN!'
  423.       call conopt(answer)
  424.       IF (answer .eqv. .FALSE.) THEN
  425.      opened = .FALSE.
  426.      return
  427.       END IF
  428.       unfmt = .FALSE.
  429.       print *,' Opening Output File'
  430.       GO TO 10
  431.       ENTRY OpDskU
  432.       unfmt = .TRUE.
  433.       print *,' Opening Unformatted File for Input or Output'
  434.       GO TO 10
  435. 10    continue
  436.       call clrscr
  437. 20    continue
  438.       print *, ' Enter disk path and filename'
  439.       call rdstr (filenm)
  440.       print *, ' Is this the correct path and filename ', filenm
  441.       call yesno(answer)
  442.       IF (answer .eqv. .FALSE.) GO TO 20
  443.       IF (unfmt .eqv. .TRUE.) THEN
  444.      open (UNIT=iolog, FILE=filenm, FORM='UNFORMATTED', ERR=30,
  445.      +         STATUS='UNKNOWN')
  446.       ELSE
  447.      open (UNIT=iolog, STATUS='UNKNOWN', FILE=filenm, ERR=30)
  448.       END IF
  449.       print *,' File ',filenm,' successfully opened.'
  450.       opened = .TRUE.
  451.       return
  452. 30    continue
  453.       print *, ' Error opening disk file ', filenm
  454.       opened = .FALSE.
  455.       call tryopt (answer)
  456.       IF (answer .eqv. .TRUE.) GO TO 20
  457.       END
  458.  
  459.       SUBROUTINE ClDisk
  460.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  461.      integer   iolog,lincnt
  462.      logical   scrnop,diskop,opened,ltrltr
  463.      character line(1:79)
  464.  
  465.       IF ((diskop .eqv. .TRUE.) .and. (opened .eqv. .TRUE.)) THEN
  466.      close(iolog)
  467.      call beep(1)
  468.      diskop = .FALSE.
  469.      opened = .FALSE.
  470.       END IF
  471.       END
  472.  
  473.       SUBROUTINE okopt (answer)  
  474.      logical answer
  475.      print *, ' Is everything all right?'
  476.      call yesno (answer)
  477.      END
  478.       SUBROUTINE tryopt (answer) 
  479.      logical answer
  480.      print *, ' Do you wish to try it again?'
  481.      call yesno (answer)
  482.      END
  483.       SUBROUTINE conopt (answer) 
  484.      logical answer
  485.      print *, ' Do you wish to continue?'
  486.      call yesno (answer)
  487.      END
  488.       SUBROUTINE endopt (answer) 
  489.      logical answer
  490.      print *, ' Do you really wish to end all this?'
  491.      call yesno (answer)
  492.      END
  493.       SUBROUTINE scropt (answer) 
  494.      logical answer
  495.      print *, ' Do you wish screen output?'
  496.      call yesno (answer)
  497.      END
  498.       SUBROUTINE dskopt (answer) 
  499.      logical answer
  500.      print *, ' Do you wish disk output?'
  501.      call yesno (answer)
  502.      END
  503.       SUBROUTINE ltropt (answer) 
  504.      logical answer
  505.      print *, ' Do you wish letter to letter plot?'
  506.      call yesno (answer)
  507.      END
  508.       SUBROUTINE lstopt (answer) 
  509.      logical answer
  510.      print *, ' Do you wish to read the list data from disk?'
  511.      call yesno (answer)
  512.      END
  513.       SUBROUTINE limopt (answer) 
  514.      logical answer
  515.      print *, ' Do you wish to list all of the values?'
  516.      call yesno (answer)
  517.      END
  518.       SUBROUTINE solopt (answer) 
  519.      logical answer
  520.      print *, ' Is the shield solid?'
  521.      call yesno (answer)
  522.      END
  523.       SUBROUTINE basopt (answer) 
  524.      logical answer
  525.      print *, ' Do you wish to modify the basic options?'
  526.      call yesno (answer)
  527.      END
  528.       SUBROUTINE itropt (answer) 
  529.      logical answer
  530.      print *, ' Do you wish to modify the iteration control?'
  531.      call yesno (answer)
  532.      END
  533.       SUBROUTINE shpopt (answer) 
  534.      logical answer
  535.      print *, ' Do you wish to modify the shield size or shape?'
  536.      call yesno (answer)
  537.      END
  538.       SUBROUTINE finopt (answer) 
  539.      logical answer
  540.      print *, ' There is a solution still in progress.'
  541.      print *, ' Do you wish to end the previous solution?'
  542.      call yesno (answer)
  543.      END
  544.  
  545.       SUBROUTINE yesno(answer)
  546.       logical answer
  547.       character*1 ch
  548. 10    continue
  549.       print *, ' Enter <Y> for yes, <N> for no.'
  550.       call rdchar (Ch)
  551.       IF ((ch .eq. 'Y') .or. (ch .eq. 'y')) THEN
  552.      answer = .TRUE.
  553.       ELSE IF ((ch .eq. 'N') .or. (ch .eq. 'n')) THEN
  554.      answer = .FALSE.
  555.       ELSE
  556.      call wrong
  557.      GO TO 10
  558.       END IF
  559.       END
  560.  
  561.       SUBROUTINE rdreal (r)
  562.       real r
  563. 10    continue
  564.       read (*,*,ERR=20) r
  565.       return
  566. 20    print *, ' Invalid real number entered.  Please reenter value.'
  567.       GO TO 10
  568.       END
  569.       SUBROUTINE rdint (i)
  570.       integer i
  571. 10    continue
  572.       read (*,*,ERR=20) i
  573.       return
  574. 20    print *, ' Invalid integer entered.  Please reenter value.'
  575.       GO TO 10
  576.       END
  577.       SUBROUTINE rdchar (c)
  578.       character c
  579. 10    continue
  580.       read (*,*,ERR=20) c
  581.       return
  582. 20    print *, ' Invalid character entered.  All characters '
  583.       print *, ' must begin and end with a single quote.  Please'
  584.       print *, ' reenter the value.'
  585.       GO TO 10
  586.       END
  587.       SUBROUTINE rdstr (s)
  588.       character*50 s
  589. 10    continue
  590.       read (*,*,ERR=20) s
  591.       return
  592. 20    print *, ' Invalid character string entered.  All strings '
  593.       print *, ' must begin and end with a single quote.  Please'
  594.       print *, ' reenter the string.'
  595.       GO TO 10
  596.       END
  597.  
  598.       SUBROUTINE rdintr                                                      
  599.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  600.      real    intrnt, lowert, uppert, prcnt, mint, maxt
  601.      print *, ' Enter internal temperature'
  602.       call rdreal (intrnt)
  603.       END
  604.       SUBROUTINE rduppr                                                      
  605.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  606.      real    intrnt, lowert, uppert, prcnt, mint, maxt
  607.      print *, ' Enter upper edge of shield temperature'
  608.       call rdreal (uppert)
  609.       END
  610.       SUBROUTINE rdlowr                                                      
  611.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  612.      real    intrnt, lowert, uppert, prcnt, mint, maxt
  613.       print *, ' Enter bottom of shield temperature'
  614.       call rdreal (lowert)
  615.       END
  616.       SUBROUTINE rdpct                                                       
  617.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  618.      real    intrnt, lowert, uppert, prcnt, mint, maxt
  619.       logical answer
  620. 10    continue
  621.       print *, ' Enter percent of the shield kept at bottom temp'
  622.       call rdreal (prcnt)
  623.       IF ((prcnt .gt. 100) .or. (prcnt .lt. 0)) THEN
  624.      print *, ' The value must be between 0 and 100.'
  625.      call wrong
  626.      IF (answer .eqv. .TRUE.) GO TO 10
  627.       END IF
  628.       IF (prcnt .eq. 0) THEN
  629.      print *, ' Zero percent implies the bottom temperature has'
  630.      print *, ' no influence.  The lower shield temperature is set'
  631.      print *, ' equal to the upper shield temperature.'
  632.      lowert = uppert
  633.      return
  634.       END IF
  635.       IF (prcnt .eq. 100) THEN
  636.      print *,' One hundred percent implies the upper temperature'
  637.      print *,' has no influence.  The upper shield temperature is'
  638.      print *,' set equal to the lower shield temperature.'
  639.      uppert = lowert
  640.      return
  641.       END IF
  642.       END
  643.       SUBROUTINE rdmxt                                                       
  644.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  645.      integer maxit, iterno
  646.      real    accfac, cnvrg, bigres
  647.      logical finis,divrg
  648. 10    continue
  649.       print *, ' Enter the maximum number of iterations per pass'
  650.       call rdint (maxit)
  651.       IF (maxit .lt. 0) THEN
  652.      print *, ' The number of iterations cannot be negative.'
  653.      GO TO 10
  654.       END IF
  655.       END
  656.       SUBROUTINE rdaccf                                                      
  657.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  658.      integer maxit, iterno
  659.      real    accfac, cnvrg, bigres
  660.      logical finis,divrg
  661. 10    continue
  662.       print *, ' Enter the acceleration factor (normally 1.84).'
  663.       print *, ' Small changes are recommended.'
  664.       call rdreal (accfac)
  665.       IF (accfac .lt. 1) THEN
  666.      print *, ' The acceleration factor cannot be less than 1'
  667.      GO TO 10
  668.       END IF
  669.       IF (accfac .ge. 2) THEN
  670.      print *, ' The acceleration factor cannot be 2 or greater.'
  671.      GO TO 10
  672.       END IF
  673.       END
  674.       SUBROUTINE rdconv                                                      
  675.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  676.      integer maxit, iterno
  677.      real    accfac, cnvrg, bigres
  678.      logical finis,divrg
  679. 10    continue
  680.       print *, ' Enter the convergence factor'
  681.       call rdreal (cnvrg)
  682.       IF (cnvrg .lt. 0) THEN
  683.      print *, ' The convergence factor cannot be negative.'
  684.      GO TO 10
  685.       END IF
  686.       END
  687.       SUBROUTINE rdshp                                                       
  688.       intrinsic mod
  689.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  690.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  691.      integer shape,size,vsize,inshp,insize,ivsize,
  692.      +       thick,hthick,vthick,square,circle,rctngl
  693.      logical solid, skewed
  694.       character ch
  695.       print *, ' ENTER'
  696.       print *, ' <S> for a square pipe/rod.'
  697.       print *, ' <C> for a round(circular) pipe/rod.'
  698.       print *, ' <R> for a rectangular pipe/rod.'
  699. 10    continue
  700.       call rdchar (ch)
  701.       IF ((ch .eq. 'S') .or. (ch .eq. 's')) THEN
  702.      shape = square
  703.      inshp = shape
  704.      vsize = size
  705.      call gtisze
  706.       ELSE IF ((ch .eq. 'C') .or. (ch .eq. 'c')) THEN
  707.      shape = circle
  708.      inshp = shape
  709.      vsize = size
  710.      call gtisze
  711.       ELSE IF ((ch .eq. 'R') .or. (ch .eq. 'r')) THEN
  712.      shape  = rctngl
  713.      inshp  = shape
  714.      vsize  = .6 * size
  715.       IF (mod(vsize,2) .eq. 0) vsize = vsize + 1
  716.      call gtisze
  717.       ELSE
  718.      call wrong
  719.      GO TO 10
  720.       END IF
  721.       END
  722.       SUBROUTINE rdishp
  723.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  724.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  725.      integer shape,size,vsize,inshp,insize,ivsize,
  726.      +       thick,hthick,vthick,square,circle,rctngl
  727.      logical solid, skewed
  728.       character ch
  729.       IF (solid .eqv. .TRUE.) THEN
  730.      call wrong
  731.      print *,' An internal shape does not exist in a rod.'
  732.      print *,' ''Solid'' must be set to hollow.'
  733.      return
  734.       END IF
  735.       print *, ' ENTER'
  736.       print *, ' <S> for a square core.'
  737.       print *, ' <C> for a round(circular) core.'
  738.       print *, ' <R> for a rectangular core.'
  739. 10    continue
  740.       call rdchar (ch)
  741.       IF ((ch .eq. 'S') .or. (ch .eq. 's')) THEN
  742.      inshp = square
  743.      ivsize = insize
  744.       ELSE IF ((ch .eq. 'C') .or. (ch .eq. 'c')) THEN
  745.      inshp = circle
  746.      ivsize = insize
  747.       ELSE IF ((ch .eq. 'R') .or. (ch .eq. 'r')) THEN
  748.      inshp = rctngl
  749.      call rdisze
  750.       ELSE
  751.      call wrong
  752.      GO TO 10
  753.       END IF
  754.       END
  755.  
  756.       SUBROUTINE rdthck                                                      
  757.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  758.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  759.      integer shape,size,vsize,inshp,insize,ivsize,
  760.      +       thick,hthick,vthick,square,circle,rctngl
  761.      logical solid, skewed
  762.       logical answer
  763.       
  764. 10    continue
  765.       IF (solid .eqv. .TRUE.) THEN
  766.      call wrong
  767.      print *,' Wall thickness is predetermined in a rod.'
  768.      print *,' ''Solid'' must be set to hollow.'
  769.      return
  770.       END IF
  771.       print *, ' Enter the thickness of the left side'
  772.       print *, ' Must be an integer > 2 and < ',size-insize+1
  773.       call rdint (hthick)
  774.       call tstsze(hthick,3,size-insize,answer)
  775.       IF (answer .eqv. .FALSE.) THEN
  776.      call wrong
  777.      GO TO 10
  778.       END IF
  779. 20    continue
  780.       print *, ' Enter the thickness of the top edge'
  781.       print *, ' Must be an integer > 2 and < ',size-ivsize+1
  782.       call rdint (vthick)
  783.       call tstsze(vthick,3,vsize-ivsize,answer)
  784.       IF (answer .eqv. .FALSE.) THEN
  785.      call wrong
  786.      call tryopt (answer)
  787.      IF (answer .eqv. .FALSE.) return
  788.      GO TO 20
  789.       END IF
  790.       call tstskw
  791.       END
  792.  
  793.       SUBROUTINE rdsold                                                      
  794.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  795.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  796.      integer shape,size,vsize,inshp,insize,ivsize,
  797.      +       thick,hthick,vthick,square,circle,rctngl
  798.      logical solid, skewed
  799.       
  800.       call solopt(solid)
  801.       call gtisze
  802.       END
  803.  
  804.       SUBROUTINE rdsize                                                 
  805.       intrinsic mod
  806.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  807.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  808.      integer shape,size,vsize,inshp,insize,ivsize,
  809.      +       thick,hthick,vthick,square,circle,rctngl
  810.      logical solid, skewed
  811.  
  812. 10    continue
  813.       print *, ' Enter the external diameter or the '
  814.       print *, ' horizontal size (width) of the pipe/rod.'
  815.       print *, ' The size must be an ODD integer from > 2 and < 80'
  816.       call rdint (size)
  817.       IF ((size .ge. 80) .or. (size .le. 2)) THEN
  818.      call wrong
  819.      GO TO 10
  820.       END IF
  821.       IF (mod(size,2) .eq. 0) THEN
  822.      call wrong
  823.      GO TO 10                                                                       
  824.       END IF
  825.       IF (shape .eq. rctngl) THEN
  826. 20       continue
  827.      print *, ' Enter the vertical size (height)'
  828.      print *, ' It must be an integer > 2 and < 80.'
  829.      call rdint (vsize)
  830.      IF ((size .ge. 80) .or. (size .le. 2)) THEN
  831.         call wrong
  832.         GO TO 20
  833.      END IF
  834.       ELSE     
  835.      vsize = size
  836.       END IF
  837.       call gtisze
  838.       END
  839.  
  840.       SUBROUTINE rdisze
  841.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  842.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  843.      integer shape,size,vsize,inshp,insize,ivsize,
  844.      +       thick,hthick,vthick,square,circle,rctngl
  845.      logical solid, skewed
  846.       logical answer
  847.       
  848. 10    continue
  849.       IF (solid .eqv. .TRUE.) THEN
  850.      call wrong
  851.      print *,' An internal size does not exist in a rod.'
  852.      print *,' ''Solid'' must be set to hollow.'
  853.      return
  854.       END IF
  855.       GO TO (20,30,40) inshp
  856.       print *, ' Internal shape value = ',inshp
  857. 20    continue
  858.       print *, ' Enter the length of a side (width or height)'
  859.       print *, ' The size must be an integer > 2 and < ',size-4
  860.       call rdint (insize)
  861.       call tstsze(insize,1,size-4,answer)
  862.       IF (answer .eqv. .FALSE.) THEN
  863.      call wrong
  864.      GO TO 20
  865.       END IF
  866.       ivsize = insize
  867.       GO TO 90
  868. 30    continue
  869.       print *, ' Enter the size (diameter) of the hole including '
  870.       print *, ' the internal core edges'
  871.       print *, ' The size must be an number > 2 and < ',size-4
  872.       call rdint (insize)
  873.       call tstsze(insize,1,size-4,answer)
  874.       IF (answer .eqv. .FALSE.) THEN
  875.      call wrong
  876.      GO TO 30
  877.       END IF
  878.       ivsize = insize
  879.       GO TO 90
  880. 40    continue
  881.       print *, ' Enter the horizontal length'
  882.       call rdint (insize)
  883.       call tstsze(insize,1,size-4,answer)
  884.       IF (answer .eqv. .FALSE.) THEN
  885.      call wrong
  886.      GO TO 40
  887.       END IF
  888. 50    continue
  889.       print *, ' Enter the vertical length (height)'
  890.       print *, ' The size must be an number > 2 and < ',vsize-4
  891.       call rdint (ivsize)
  892.       call tstsze(ivsize,3,vsize-4,answer)
  893.       IF (answer .eqv. .FALSE.) THEN
  894.      call wrong
  895.      GO TO 50
  896.       END IF
  897. 90    continue
  898.       call gtthck
  899.       END
  900.  
  901.       SUBROUTINE rdrwcl (n,rowcol,begend,size)
  902.       integer n, rowcol, begend, size
  903.       character*6 rc
  904.       character*9 be
  905.  
  906.       IF (begend .eq. 1) THEN
  907.      be = 'beginning'
  908.       ELSE
  909.      be = 'ending   '
  910.       END IF
  911.       IF (rowcol .eq. 1) THEN
  912.      rc = 'row   '
  913.       ELSE
  914.      rc = 'column'
  915.       END IF
  916. 20    continue
  917.       print *, 'Enter ',be,' ',rc
  918.       call rdint (n)
  919.       IF ((n .lt. 1) .or. (n .gt. size)) THEN
  920.      print *,' Values must be greater than 1 and less than',size
  921.      GO TO 20
  922.       END IF
  923.       END 
  924.  
  925.       SUBROUTINE rdlist 
  926.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  927.      integer   iolog,lincnt
  928.      logical   scrnop,diskop,opened,ltrltr
  929.      character line(1:79)
  930.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  931.      real temper (1:79,1:79)
  932.      integer tmpshp(1:79,1:8)
  933.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  934.       logical answer
  935.       real value
  936.       integer row,col
  937.  
  938.       return
  939.       call lstopt (answer)
  940.       IF (answer .eqv. .FALSE.) return
  941.       call OpDskI 
  942.       IF (opened .eqv. .FALSE.) return
  943.       call initmp
  944. * Read numerical values from disk
  945. 30       continue
  946.      read (iolog, '(I3,I3,f11.5)', END = 40) row, col, value
  947.      temper(row,col) = value
  948.      GO TO 30
  949. 40    continue
  950.       call cldisk
  951.       print *, ' W A R N I N G.  If you try to graph this data you'
  952.       print *, ' may get funny looking results.  (If you must fudge,'
  953.       print *, ' first run a simple problem of the same shapes,sizes'
  954.       print *, ' temperatures etc. as the one you are reading.  You'
  955.       print *, ' can set the number of iterations to zero.)'
  956.       END
  957.  
  958.       SUBROUTINE wrltrs(letter,maxt,mint,tincr)
  959.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  960.      integer   iolog,lincnt
  961.      logical   scrnop,diskop,opened,ltrltr
  962.      character line(1:79)
  963.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  964.      integer maxit, iterno
  965.      real    accfac, cnvrg, bigres
  966.      logical finis,divrg
  967.       integer i
  968.       character*1 letter(1:17)
  969.       real maxt, mint, temp, tincr, incr
  970.  
  971.       call clrscr
  972.       IF (finis .eqv. .TRUE.) THEN
  973.      call wcvrg
  974.       ELSE
  975.      call wncvrg
  976.       END IF
  977.       call wuppr
  978.       call wintr
  979.       call wlowr
  980.       print *, ' RANGE OF TEMPERATURES'
  981.       temp = mint
  982.       incr = tincr
  983.       do 20 i = 1,16
  984.      call wrltr(letter,temp,incr,i)
  985. 20    continue
  986.       incr = maxt - temp
  987.       call wrltr(letter,temp,incr,17)
  988.       IF (scrnop .eqv. .TRUE.) call prentr
  989.       END
  990.  
  991.       SUBROUTINE wrltr(letter,temp1,incr,i)
  992.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  993.      integer   iolog,lincnt
  994.      logical   scrnop,diskop,opened,ltrltr
  995.      character line(1:79)
  996.       real temp1, temp2, incr
  997.       character*1 ch
  998.       character*1 letter(1:17)
  999.  
  1000.       ch = letter(i)
  1001.       temp2 = temp1 + incr
  1002.       IF (scrnop .eqv. .TRUE.) 
  1003.      +   print 100, ch,' ranges from ',temp1,' to ',temp2,' degrees.'
  1004.       IF ((diskop .eqv. .TRUE.) .and. (opened .eqv. .TRUE.))
  1005.      +   write (iolog,100) ch,' ranges from ',temp1,' to ',temp2,
  1006.      +   ' degrees.'
  1007.       temp1 = temp2
  1008. 100   FORMAT (1x,a1,a13,f11.5,a4,f11.5,a1)
  1009.       END
  1010.  
  1011.       SUBROUTINE beep(n)
  1012.       intrinsic char
  1013.       integer i,n
  1014.       character*1 lebeep
  1015.       lebeep = char(7)
  1016.       do 10 i = 1,n
  1017.      print *,lebeep
  1018. 10    continue
  1019.       END
  1020.  
  1021.       SUBROUTINE wrbas
  1022.       print *, ' BASIC PARAMETERS'
  1023.       call wshape
  1024.       call wsolid
  1025.       call wuppr
  1026.       call wintr
  1027.       call wlowr
  1028.       call wprcnt
  1029.       END
  1030.  
  1031.       SUBROUTINE writer
  1032.       print *, ' ITERATION PARAMETERS'
  1033.       call wmaxit
  1034.       call waccf
  1035.       call wconv
  1036.       END
  1037.  
  1038.       SUBROUTINE wrshp
  1039.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1040.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1041.      integer shape,size,vsize,inshp,insize,ivsize,
  1042.      +       thick,hthick,vthick,square,circle,rctngl
  1043.      logical solid, skewed
  1044.  
  1045.       print *, ' SHAPE PARAMETERS'
  1046.       call wshape
  1047.       call wsize
  1048.       call wsolid
  1049.       IF (solid .eqv. .TRUE.) return
  1050.       call wishpe
  1051.       call wisize
  1052.       call wskew
  1053.       call wthick
  1054.       END
  1055.  
  1056.       SUBROUTINE wshape
  1057.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1058.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1059.      integer shape,size,vsize,inshp,insize,ivsize,
  1060.      +       thick,hthick,vthick,square,circle,rctngl
  1061.      logical solid, skewed
  1062.  
  1063.       
  1064.       GO TO (10,20,30) shape
  1065. 10    continue
  1066.       print *, ' The External Shape = Square'
  1067.       GO TO 90
  1068. 20    continue
  1069.       print *, ' The External Shape = Round'
  1070.       GO TO 90
  1071. 30    continue
  1072.       print *, ' The External Shape = Rectangular'
  1073.       GO TO 90
  1074. 90    continue
  1075.       END
  1076.  
  1077.       SUBROUTINE wishpe
  1078.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1079.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1080.      integer shape,size,vsize,inshp,insize,ivsize,
  1081.      +       thick,hthick,vthick,square,circle,rctngl
  1082.      logical solid, skewed
  1083.  
  1084.       IF (solid .eqv. .TRUE.) GO TO 90
  1085.       print *, ' The Internal '
  1086.       GO TO (10,20,30) inshp
  1087. 10    continue
  1088.       print *, ' The Internal Shape = Square'
  1089.       GO TO 90
  1090. 20    continue
  1091.       print *, ' The Internal Shape = Round'
  1092.       GO TO 90
  1093. 30    continue
  1094.       print *, ' The Internal Shape = Rectangular'
  1095.       GO TO 90
  1096. 90    continue
  1097.       END
  1098.  
  1099.       SUBROUTINE wsolid
  1100.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1101.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1102.      integer shape,size,vsize,inshp,insize,ivsize,
  1103.      +       thick,hthick,vthick,square,circle,rctngl
  1104.      logical solid, skewed
  1105.  
  1106.       IF (solid .eqv. .TRUE.) THEN
  1107.      print *, ' The core of the shield = Solid'
  1108.       ELSE
  1109.      print *, ' The core of the shield = Hollow'      
  1110.       END IF   
  1111.       END
  1112.  
  1113.       SUBROUTINE wintr
  1114.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  1115.      real    intrnt, lowert, uppert, prcnt, mint, maxt
  1116.       print *, ' Internal temperature = ',intrnt
  1117.       END
  1118.       SUBROUTINE wuppr
  1119.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  1120.      real    intrnt, lowert, uppert, prcnt, mint, maxt
  1121.       print *, ' Upper    temperature = ',uppert
  1122.       END
  1123.       SUBROUTINE wlowr
  1124.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  1125.      real    intrnt, lowert, uppert, prcnt, mint, maxt
  1126.       print *, ' Lower    temperature = ',lowert
  1127.       END
  1128.       SUBROUTINE wprcnt
  1129.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  1130.      real    intrnt, lowert, uppert, prcnt, mint, maxt
  1131.       print *, ' Amount of pipe/rod that is buried/immersed = ',prcnt
  1132.       END
  1133.       SUBROUTINE wmaxit
  1134.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  1135.      integer maxit, iterno
  1136.      real    accfac, cnvrg, bigres
  1137.      logical finis,divrg
  1138.       print *, ' The number of iterations in one pass = ',maxit
  1139.       END
  1140.       SUBROUTINE waccf
  1141.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  1142.      integer maxit, iterno
  1143.      real    accfac, cnvrg, bigres
  1144.      logical finis,divrg
  1145.       print *, ' The acceration factor = ',accfac
  1146.       END
  1147.       SUBROUTINE wconv
  1148.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  1149.      integer maxit, iterno
  1150.      real    accfac, cnvrg, bigres
  1151.      logical finis,divrg
  1152.       print *, ' The convergence criterion is ',cnvrg,' degrees.'
  1153.       END
  1154.  
  1155.       SUBROUTINE wsize
  1156.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1157.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1158.      integer shape,size,vsize,inshp,insize,ivsize,
  1159.      +       thick,hthick,vthick,square,circle,rctngl
  1160.      logical solid, skewed
  1161.      print *, ' The external horizontal size = ',size
  1162.      call wvsize
  1163.       END
  1164.       SUBROUTINE wvsize
  1165.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1166.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1167.      integer shape,size,vsize,inshp,insize,ivsize,
  1168.      +       thick,hthick,vthick,square,circle,rctngl
  1169.      logical solid, skewed
  1170.       print *, ' The external vertical   size = ',vsize
  1171.       END
  1172.  
  1173.       SUBROUTINE wisize
  1174.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1175.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1176.      integer shape,size,vsize,inshp,insize,ivsize,
  1177.      +       thick,hthick,vthick,square,circle,rctngl
  1178.      logical solid, skewed
  1179.       print *, ' The internal horizontal size = ',insize
  1180.       call wivsze
  1181.       END
  1182.       SUBROUTINE wivsze
  1183.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1184.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1185.      integer shape,size,vsize,inshp,insize,ivsize,
  1186.      +       thick,hthick,vthick,square,circle,rctngl
  1187.      logical solid, skewed
  1188.       print *, ' The internal vertical   size = ',ivsize
  1189.       END
  1190.  
  1191.       SUBROUTINE wskew
  1192.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1193.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1194.      integer shape,size,vsize,inshp,insize,ivsize,
  1195.      +       thick,hthick,vthick,square,circle,rctngl
  1196.      logical solid, skewed
  1197.       IF (solid .eqv. .TRUE.) return
  1198.       IF (skewed .eqv. .TRUE.) THEN
  1199.      print *,' The internal core is not centered horizontally.'
  1200.       ELSE
  1201.      print *,' The internal core is centered horizontally.'
  1202.       END IF
  1203.       END
  1204.  
  1205.       SUBROUTINE wthick
  1206.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1207.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1208.      integer shape,size,vsize,inshp,insize,ivsize,
  1209.      +       thick,hthick,vthick,square,circle,rctngl
  1210.      logical solid, skewed
  1211.       print *, ' The left side horizontal thickness = ',hthick
  1212.       call wvthck
  1213.       END
  1214.       SUBROUTINE wvthck
  1215.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1216.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1217.      integer shape,size,vsize,inshp,insize,ivsize,
  1218.      +       thick,hthick,vthick,square,circle,rctngl
  1219.      logical solid, skewed
  1220.       print *, ' The top       vertical   thickness = ',vthick
  1221.       END
  1222.        
  1223.       SUBROUTINE wcvrg
  1224.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  1225.      integer maxit, iterno
  1226.      real    accfac, cnvrg, bigres
  1227.      logical finis,divrg
  1228.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  1229.      integer   iolog,lincnt
  1230.      logical   scrnop,diskop,opened,ltrltr
  1231.      character line(1:79)
  1232.       print *, ' With convergence value = ', cnvrg,' convergence' 
  1233.       print *, ' was achieved in ', iterno,' iterations.'
  1234.       IF ((diskop .eqv. .TRUE.) .and. (opened .eqv. .TRUE.)) THEN
  1235.      write(iolog,*) ' With convergence value = ', cnvrg,
  1236.      +   ' convergence'
  1237.      write (iolog,*) ' was achieved in ', iterno,' iterations.'
  1238.       END IF
  1239.       END
  1240.       SUBROUTINE wncvrg
  1241.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  1242.      integer maxit, iterno
  1243.      real    accfac, cnvrg, bigres
  1244.      logical finis,divrg
  1245.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  1246.      integer   iolog,lincnt
  1247.      logical   scrnop,diskop,opened,ltrltr
  1248.      character line(1:79)
  1249.       print *, ' No convergence yet in ', iterno, ' iterations.'
  1250.       print *, ' Current convergence is ', bigres, ' degrees.'
  1251.       print *, ' Convergence goal is ',cnvrg,' degrees.'
  1252.       IF ((diskop .eqv. .TRUE.) .and. (opened .eqv. .TRUE.)) THEN
  1253.      write (iolog,*) ' No convergence yet in ', iterno, 
  1254.      +   ' iterations.'
  1255.      write (iolog,*) ' Current convergence is ', bigres, 
  1256.      +   ' degrees.'
  1257.      write (iolog,*) ' Convergence goal is ',cnvrg,' degrees.'
  1258.       END IF
  1259.       END
  1260.       
  1261.       SUBROUTINE wdivrg (row,col,tempt)
  1262.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  1263.      integer maxit, iterno
  1264.      real    accfac, cnvrg, bigres
  1265.      logical finis,divrg
  1266.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  1267.      real    intrnt, lowert, uppert, prcnt, mint, maxt
  1268.       integer row,col
  1269.       real tempt
  1270.  
  1271.       call clrscr
  1272.       print *,' Solution is diverging.  Check problem setup.'
  1273.       print *,' If necessary modify the acceleration factor'
  1274.       print *,' and/or the convergence criterion.'
  1275.       print *,' Maximum  temperature = ',maxt
  1276.       print *,' Minimum  temperature = ',mint
  1277.       print *,' Computed temperature = ',tempt
  1278.       print *,' Row = ',row,'  Column = ',col
  1279.       print *,' Iteration number = ',interno
  1280.       call beep(4)
  1281.       call prentr
  1282.       END
  1283.  
  1284.       SUBROUTINE wrtmsh
  1285.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1286.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1287.      integer shape,size,vsize,inshp,insize,ivsize,
  1288.      +       thick,hthick,vthick,square,circle,rctngl
  1289.      logical solid, skewed
  1290.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1291.      real temper (1:79,1:79)
  1292.      integer tmpshp(1:79,1:8)
  1293.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1294.       integer i
  1295.       do 10 i = 1,vsize
  1296.      print *,' ',i,
  1297.      +           ' ',tmpshp(i,1),' ',tmpshp(i,2),' ',tmpshp(i,3),
  1298.      +           ' ',tmpshp(i,4),' ',tmpshp(i,5),' ',tmpshp(i,6),
  1299.      +           ' ',tmpshp(i,7),' ',tmpshp(i,8)
  1300. 10    continue
  1301.       END
  1302.  
  1303.       SUBROUTINE wrong
  1304.       print *, ' You entered and invalid option or value.'
  1305.       call prentr
  1306.       END
  1307.  
  1308.       SUBROUTINE initar
  1309.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  1310.      integer   iolog,lincnt
  1311.      logical   scrnop,diskop,opened,ltrltr
  1312.      character line(1:79)
  1313.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1314.      real temper (1:79,1:79)
  1315.      integer tmpshp(1:79,1:8)
  1316.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1317.       integer i,j
  1318.       character blank
  1319.       data blank /' '/
  1320.  
  1321.       return
  1322.       ENTRY initln                                                      
  1323.       do 10 i = 1,79
  1324.      line(i) = blank
  1325. 10    continue
  1326.       return
  1327.       ENTRY initts                                                      
  1328.       DO 20 j = 1,8
  1329.       DO 15 i = 1,79
  1330.      tmpshp(i,j) = 0
  1331. 15    continue
  1332. 20    continue
  1333.       return
  1334.       ENTRY initmp                                                      
  1335.       DO 30 i = 1,79
  1336.       DO 25 j = 1,79
  1337.      temper(i,j) = 0
  1338. 25    continue
  1339. 30    continue
  1340.       return
  1341.       END
  1342.  
  1343.       SUBROUTINE init
  1344.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1345.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1346.      integer shape,size,vsize,inshp,insize,ivsize,
  1347.      +       thick,hthick,vthick,square,circle,rctngl
  1348.      logical solid, skewed
  1349.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1350.      real    temper (1:79,1:79)
  1351.      integer tmpshp(1:79,1:8)
  1352.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1353.       
  1354.       square = 1
  1355.       circle = 2
  1356.       rctngl = 3
  1357.       els    = 1
  1358.       wlb    = 2
  1359.       wle    = 3
  1360.       ils    = 4
  1361.       irs    = 5
  1362.       wrb    = 6
  1363.       wre    = 7
  1364.       ers    = 8
  1365.       END
  1366.  
  1367.       SUBROUTINE initlt(letter)
  1368.       character*1 letter(1:17)
  1369.       letter(1)  = 'A'
  1370.       letter(2)  = 'B'
  1371.       letter(3)  = 'C'
  1372.       letter(4)  = 'D'
  1373.       letter(5)  = 'E'
  1374.       letter(6)  = 'F'
  1375.       letter(7)  = 'G'
  1376.       letter(8)  = 'H'
  1377.       letter(9)  = 'I'
  1378.       letter(10) = 'J'
  1379.       letter(11) = 'K'
  1380.       letter(12) = 'L'
  1381.       letter(13) = 'M'
  1382.       letter(14) = 'N'
  1383.       letter(15) = 'O'
  1384.       letter(16) = 'P'
  1385.       letter(17) = 'Q'
  1386.       END
  1387.       
  1388.       SUBROUTINE initsl
  1389.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  1390.      integer   iolog,lincnt
  1391.      logical   scrnop,diskop,opened,ltrltr
  1392.      character line(1:79)
  1393.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  1394.      integer maxit, iterno
  1395.      real    accfac, cnvrg, bigres
  1396.      logical finis,divrg
  1397.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1398.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1399.      integer shape,size,vsize,inshp,insize,ivsize,
  1400.      +       thick,hthick,vthick,square,circle,rctngl
  1401.      logical solid, skewed
  1402.       common /tmpctl/ intrnt, lowert, uppert, prcnt, mint, maxt
  1403.      real intrnt, lowert, uppert, prcnt, mint, maxt
  1404.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1405.      real temper (1:79,1:79)
  1406.      integer tmpshp(1:79,1:8)
  1407.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1408.       
  1409.       return
  1410.       ENTRY initio
  1411.       iolog  = 20
  1412.       lincnt = 0
  1413.       scrnop = .TRUE.
  1414.       diskop = .FALSE.
  1415.       ltrltr = .FALSE.
  1416.       return
  1417. *     Initialize Basic Parameters
  1418.       ENTRY initbs
  1419.       uppert = 150
  1420.       intrnt = -350
  1421.       lowert = 3600
  1422.       prcnt  = 1
  1423.       return
  1424.       ENTRY initit
  1425.       maxit  = 200
  1426.       accfac = 1.84
  1427.       cnvrg  = 10
  1428.       finis = .TRUE.
  1429.       return
  1430.       ENTRY initsh
  1431.       shape  = rctngl
  1432.       size   = 79
  1433.       vsize  = 51
  1434.       thick  = 29
  1435.       inshp  = square
  1436.       insize = 23
  1437.       ivsize = insize
  1438.       hthick = 29
  1439.       vthick = 15
  1440.       solid  = .FALSE.
  1441.       skewed = .FALSE.
  1442.       return
  1443.       END
  1444.  
  1445.       SUBROUTINE initlm(rowb,colb,rowe,cole)
  1446.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1447.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1448.      integer shape,size,vsize,inshp,insize,ivsize,
  1449.      +       thick,hthick,vthick,square,circle,rctngl
  1450.      logical solid, skewed
  1451.       integer rowb,colb,rowe,cole
  1452.       rowb = 1
  1453.       colb = 1
  1454.       rowe = vsize
  1455.       cole = size
  1456.       END
  1457.  
  1458.       SUBROUTINE tstskw 
  1459.       intrinsic mod
  1460.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1461.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1462.      integer shape,size,vsize,inshp,insize,ivsize,
  1463.      +       thick,hthick,vthick,square,circle,rctngl
  1464.      logical solid, skewed
  1465.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1466.      real temper (1:79,1:79)
  1467.      integer tmpshp(1:79,1:8)
  1468.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1469.       integer x
  1470.  
  1471.       IF (solid .eqv. .TRUE.) THEN
  1472.      skewed = .FALSE.
  1473.      return
  1474.       END IF
  1475.       x = size-(insize-2)
  1476.       skewed = .TRUE.
  1477.       IF (mod(x,2) .ne. 0) return
  1478.       x = x/2
  1479.       IF (hthick .eq. x) skewed = .FALSE.
  1480.       END
  1481.  
  1482.       SUBROUTINE tstrc (n1,n2,rowcol,answer)
  1483.       integer n1,n2,rowcol
  1484.       logical answer
  1485.       character*6 rc
  1486.  
  1487.       IF (rowcol .eq. 1) THEN
  1488.      rc = 'row '
  1489.       ELSE
  1490.      rc = 'column '
  1491.       END IF
  1492.       answer = .TRUE.
  1493.       IF (n1 .gt. n2) THEN
  1494.      print *, ' The beginning ', rc, n1, 
  1495.      +   ' is greater than the ending  ', rc, n2
  1496.      answer = .FALSE.
  1497.       END IF 
  1498.       END
  1499.  
  1500.       SUBROUTINE tstsze (val1,val2,val3,answer)
  1501.       integer val1,val2,val3
  1502.       logical answer
  1503.       answer = .TRUE.
  1504.       IF ((val1 .lt. val2) .or. (val1 .gt. val3)) answer = .FALSE.
  1505.       END
  1506.  
  1507.       SUBROUTINE inwall(row,col,answer)
  1508.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1509.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1510.      integer shape,size,vsize,inshp,insize,ivsize,
  1511.      +       thick,hthick,vthick,square,circle,rctngl
  1512.      logical solid, skewed
  1513.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1514.      real temper (1:79,1:79)
  1515.      integer tmpshp(1:79,1:8)
  1516.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1517.       integer row,col
  1518.       logical answer
  1519.  
  1520.       IF ((row .le. 1) .or. (row .ge. vsize)) 
  1521.      +   GO TO 90
  1522.       IF (tmpshp(row,wlb) .le. 0)
  1523.      +   GO TO 90
  1524.       IF ((col .lt. tmpshp(row,wlb)) .or. (col .gt. tmpshp(row,wre)))
  1525.      +   GO TO 90
  1526.       IF (solid .eqv. .TRUE.) 
  1527.      +   GO TO 95
  1528.       IF (((row .ge. vthick) .and. (row .le. vthick+ivsize-1)) .and.
  1529.      +   ((col .ge. tmpshp(row,ils)) .and. (col .le. tmpshp(row,irs))))
  1530.      +   GO TO 90
  1531.       GO TO 95
  1532. 90    continue
  1533.       answer = .FALSE.
  1534.       return
  1535. 95    continue
  1536.       answer = .TRUE.
  1537.       return
  1538.       END
  1539.  
  1540.       SUBROUTINE onwall(row,col,answer)
  1541.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1542.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1543.      integer shape,size,vsize,inshp,insize,ivsize,
  1544.      +       thick,hthick,vthick,square,circle,rctngl
  1545.      logical solid, skewed
  1546.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1547.      real temper (1:79,1:79)
  1548.      integer tmpshp(1:79,1:8)
  1549.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1550.       integer row,col
  1551.       logical answer
  1552.  
  1553.       IF ((row .lt. 1) .or. (row .gt. vsize))
  1554.      +   GO TO 90
  1555.       IF ((col .lt. 1) .or. (col .gt. size))
  1556.      +   GO TO 90
  1557.       IF (solid .eqv. .TRUE.) GO TO 95
  1558.       IF (((row .gt. vthick) .and. (row .lt. vthick+ivsize-1)) .and.
  1559.      +   ((col .gt. tmpshp(row,ils)) .and. (col .lt. tmpshp(row,irs))))
  1560.      +   GO TO 90
  1561.       GO TO 95
  1562. 90    continue
  1563.       answer = .FALSE.
  1564.       return
  1565. 95    continue
  1566.       answer = .TRUE.
  1567.       return
  1568.       END
  1569.  
  1570.       SUBROUTINE gtbas
  1571.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1572.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1573.      integer shape,size,vsize,inshp,insize,ivsize,
  1574.      +       thick,hthick,vthick,square,circle,rctngl
  1575.      logical solid, skewed
  1576.       integer option
  1577.       logical answer
  1578.  
  1579.       call basopt(answer)
  1580.       IF (answer .eqv. .FALSE.) return
  1581. 5     continue
  1582.       call clrscr
  1583.       call wrbas
  1584.       print *, ' ENTER'
  1585.       print *, ' 1  To accept all variables'
  1586.       print *, ' 2  To reinitialize all basic variables'
  1587.       print *, ' 3  To change all variables'
  1588.       print *, ' 4  To change external and internal shield shapes'
  1589.       print *, ' 5  To change Top Edge    temperature'
  1590.       print *, ' 6  To change Internal    temperature'
  1591.       print *, ' 7  To change Bottom Edge temperature'
  1592.       print *, ' 8  To change Percent of Shield at Bottom Temperature'
  1593.       print *, ' 9  To change Solid Option'
  1594.       call rdint (Option)
  1595.       GO TO (90,10,15,20,25,30,35,40,45) Option
  1596.       call wrong
  1597.       GO TO 5
  1598. 10    continue
  1599.       call initbs
  1600.       GO TO 5
  1601. 15    continue
  1602.       call rdshp
  1603.       call rduppr
  1604.       call rdintr
  1605.       call rdlowr
  1606.       call rdpct
  1607.       call rdsold
  1608.       GO TO 5
  1609. 20    call rdshp
  1610.       GO TO 5
  1611. 25    call rduppr
  1612.       GO TO 5
  1613. 30    call rdintr
  1614.       GO TO 5
  1615. 35    call rdlowr
  1616.       GO TO 5
  1617. 40    call rdpct
  1618.       GO TO 5
  1619. 45    call rdsold
  1620.       GO TO 5
  1621. 90    continue
  1622.       inshp = shape
  1623.       END
  1624.  
  1625.       SUBROUTINE gtiter
  1626.       common /itrctl/ maxit,iterno,accfac,cnvrg,bigres,finis,divrg
  1627.      integer maxit, iterno
  1628.      real    accfac, cnvrg, bigres
  1629.      logical finis,divrg
  1630.       integer option
  1631.       logical answer
  1632.  
  1633.       call itropt (answer)
  1634.       IF (answer .eqv. .FALSE.) return
  1635. 10    continue
  1636.       call clrscr
  1637.       call writer
  1638.       print *, ' ENTER'
  1639.       print *, ' 1  To accept all variables'
  1640.       print *, ' 2  To reinitialize all iteration variables'
  1641.       print *, ' 3  To change all variables'
  1642.       print *, ' 4  To change number of iterations'
  1643.       print *, ' 5  To change the acceleration factor'
  1644.       print *, ' 6  To change the convergence factor'
  1645.       call rdint (Option)
  1646.       GO TO (90,20,30,40,50,60) option
  1647.       call wrong
  1648.       GO TO 10
  1649. 20    continue
  1650.       call initit
  1651.       GO TO 10
  1652. 30    continue
  1653.       call rdmxt
  1654.       call rdaccf
  1655.       call rdconv
  1656.       GO TO 10
  1657. 40    continue
  1658.       call rdmxt
  1659.       GO TO 10
  1660. 50    continue
  1661.       call rdaccf
  1662.       GO TO 10
  1663. 60    continue
  1664.       call rdconv
  1665.       GO TO 10
  1666. 90    continue
  1667.       END
  1668.  
  1669.       SUBROUTINE gtshp
  1670.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1671.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1672.      integer shape,size,vsize,inshp,insize,ivsize,
  1673.      +       thick,hthick,vthick,square,circle,rctngl
  1674.      logical solid, skewed
  1675.       integer option
  1676.       logical answer
  1677.  
  1678.       call shpopt (answer)
  1679.       IF (answer .eqv. .FALSE.) return
  1680. 10    continue
  1681.       call clrscr
  1682.       call wrshp
  1683.       print *, ' ENTER'
  1684.       print *, ' 1  To accept all variables'
  1685.       print *, ' 2  To reinitialize all shape variables'
  1686.       print *, ' 3  To change all variables'
  1687.       print *, ' 4  To change external shield shape'
  1688.       print *, ' 5  To change external shield size'
  1689.       print *, ' 6  To change internal core shape'
  1690.       print *, ' 7  To change internal core size'
  1691.       print *, ' 8  To change shield wall thickness'
  1692.       print *, ' 9  To change solid option'
  1693.       call rdint (Option)
  1694.       GO TO (90,15,20,25,30,35,40,50,60) option
  1695.       call wrong
  1696.       GO TO 10
  1697. 15    continue
  1698.       call initsh
  1699.       GO TO 10
  1700. 20    continue
  1701.       call rdshp
  1702.       call rdsize
  1703.       call rdishp
  1704.       call rdisze
  1705.       call rdthck
  1706.       call rdsold
  1707.       GO TO 10
  1708. 25    continue
  1709.       call rdshp
  1710.       GO TO 10
  1711. 30    continue
  1712.       call rdsize
  1713.       GO TO 10
  1714. 35    continue
  1715.       call rdishp
  1716.       GO TO 10
  1717. 40    continue
  1718.       call rdisze
  1719.       GO TO 10
  1720. 50    continue
  1721.       call rdthck
  1722.       GO TO 10
  1723. 60    continue
  1724.       call rdsold
  1725.       GO TO 10
  1726. 90    continue
  1727.       IF ((insize .eq. 0) .or. (ivsize .eq. 0)) solid = .TRUE.
  1728.       END
  1729.  
  1730.       SUBROUTINE gtisze
  1731.       intrinsic mod
  1732.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1733.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1734.      integer shape,size,vsize,inshp,insize,ivsize,
  1735.      +       thick,hthick,vthick,square,circle,rctngl
  1736.      logical solid, skewed
  1737.  
  1738.      IF (solid .eqv. .TRUE.) THEN
  1739.         insize = 0
  1740.         ivsize = 0
  1741.      ELSE
  1742.         insize = .4 * size
  1743.         IF (mod(insize,2) .eq. 0) insize = insize + 1
  1744.         ivsize = .4 * vsize
  1745.         IF (mod(ivsize,2) .eq. 0) ivsize = ivsize + 1
  1746.      END IF
  1747.      call gtthck
  1748.       END
  1749.  
  1750.       SUBROUTINE gtthck
  1751.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1752.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1753.      integer shape,size,vsize,inshp,insize,ivsize,
  1754.      +       thick,hthick,vthick,square,circle,rctngl
  1755.      logical solid, skewed
  1756.  
  1757.      IF (solid .eqv. .TRUE.) THEN
  1758.         hthick = size
  1759.         vthick = vsize
  1760.      ELSE
  1761.         hthick = ( size - (insize - 2))/2
  1762.         vthick = (vsize - (ivsize - 2))/2
  1763.      END IF
  1764.      END
  1765.  
  1766.       SUBROUTINE gtioop (answer)
  1767.       common /ioctl/ iolog,lincnt,scrnop,diskop,opened,ltrltr,line
  1768.      integer   iolog,lincnt
  1769.      logical   scrnop,diskop,opened,ltrltr
  1770.      character line(1:79)
  1771.       logical answer,ans
  1772.                          
  1773. 10    continue
  1774.       call scropt(scrnop)
  1775.       call dskopt(diskop)
  1776.       IF (diskop .eqv. .TRUE.) call OpDskO
  1777.       IF ((opened .eqv. .FALSE.) .and. (scrnop .eqv. .FALSE.)) THEN
  1778.      print *, ' No device available for output'
  1779.      call tryopt (ans)
  1780.      IF (ans .eqv. .TRUE.) GO TO 10
  1781.      answer = .FALSE.
  1782.       ELSE
  1783.      answer = .TRUE.
  1784.       END IF
  1785.       END 
  1786.  
  1787.       SUBROUTINE gtindx(row, collb, colle, colrb, colre, pieces)
  1788.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1789.      real temper (1:79,1:79)
  1790.      integer tmpshp(1:79,1:8)
  1791.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1792.       integer row,colrb,colre,collb,colle,pieces
  1793.                   
  1794.       IF (tmpshp(row,ils) .eq. 0) THEN
  1795.      collb  = tmpshp(row,wlb)
  1796.      colle  = tmpshp(row,wre)
  1797.      colrb  = 0
  1798.      colre  = 0
  1799.      pieces = 1
  1800.      return
  1801.       ELSE
  1802.      collb  = tmpshp(row,wlb)
  1803.      colle  = tmpshp(row,wle)
  1804.      colrb  = tmpshp(row,wrb)
  1805.      colre  = tmpshp(row,wre)
  1806.      pieces = 2
  1807.       END IF
  1808.       END
  1809.  
  1810.       SUBROUTINE gtlmts(rowb,colb,rowe,cole)
  1811.       logical answer
  1812.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1813.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1814.      integer shape,size,vsize,inshp,insize,ivsize,
  1815.      +       thick,hthick,vthick,square,circle,rctngl
  1816.      logical solid, skewed
  1817.       integer rowb,colb,rowe,cole,option,r,c,b,e
  1818.       data r/1/,c/2/,b/1/,e/2/
  1819.  
  1820. 20    continue
  1821.       call initlm (rowb,colb,rowe,cole)
  1822.       GO TO 80
  1823. 30    continue
  1824.       call rdrwcl (rowb,r,b,size)
  1825.       call rdrwcl (colb,c,b,vsize)
  1826.       call rdrwcl (rowe,r,e,size)
  1827.       call rdrwcl (cole,c,e,vsize)
  1828.       GO TO 80
  1829. 40    continue
  1830.       call rdrwcl (rowb,r,b,size)
  1831.       GO TO 80
  1832. 50    continue
  1833.       call rdrwcl (colb,c,b,vsize)
  1834.       GO TO 80
  1835. 60    continue
  1836.       call rdrwcl (rowe,r,e,size)
  1837.       GO TO 80
  1838. 70    continue
  1839.       call rdrwcl (cole,c,e,vsize)
  1840.       GO TO 80
  1841. 80    continue
  1842.       call clrscr
  1843.       print *, ' Beginning row    = ', rowb
  1844.       print *, ' Beginning column = ', colb
  1845.       print *, ' Ending row       = ', rowe
  1846.       print *, ' Ending column    = ', cole
  1847.       print *
  1848.       call tstrc (rowb,rowe,r,answer)
  1849.       IF (answer .eqv. .FALSE.) GO TO 30
  1850.       call tstrc (colb,cole,c,answer)
  1851.       IF (answer .eqv. .FALSE.) GO TO 30
  1852.       print *, ' ENTER'
  1853.       print *, ' 1  To accept all values.'
  1854.       print *, ' 2  To change all values.'
  1855.       print *, ' 3  To change beginning row.'
  1856.       print *, ' 4  To change beginning column.'
  1857.       print *, ' 5  To change ending row.'
  1858.       print *, ' 6  To change ending column.'
  1859.       call rdint (Option)
  1860.       GO TO (90,30,40,50,60,70) option
  1861.       call wrong
  1862.       GO TO 80
  1863. 90    continue
  1864.       END
  1865.  
  1866.       SUBROUTINE mkrnd (a,b,d,i,j)
  1867.       intrinsic abs, sqrt, nint, real
  1868.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1869.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1870.      integer shape,size,vsize,inshp,insize,ivsize,
  1871.      +       thick,hthick,vthick,square,circle,rctngl
  1872.      logical solid, skewed
  1873.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1874.      real temper (1:79,1:79)
  1875.      integer tmpshp(1:79,1:8)
  1876.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1877.       integer row,rowb,row2,rowe,col,colm,a,b,d,i,j,x,xc,cola
  1878.       real r,y
  1879.  
  1880.       rowb = b 
  1881.       rowe = b + (d-1)/2
  1882.       xc   = a + (d-1)/2
  1883.       r    = rowe-rowb
  1884.       row2 = rowb + (r + 1)/2
  1885.       cola = 0
  1886.       do 30 row = rowb+1,rowe-1
  1887.      y = rowe - row
  1888.      x = nint(sqrt(r*r-y*y))
  1889.      col  = xc-x
  1890.      colm = size-col+1
  1891.      tmpshp(row,        i) = col
  1892.      tmpshp(vsize-row+1,i) = col
  1893.      tmpshp(row,        j) = colm
  1894.      tmpshp(vsize-row+1,j) = colm
  1895.      IF (col .eq. a) cola = cola + 1
  1896. 30    continue
  1897.       tmpshp(rowe,i) = a
  1898.       tmpshp(rowe,j) = size-a+1
  1899.       cola = cola + 1  
  1900.       col  = xc - cola
  1901.       colm = size-col+1
  1902.       tmpshp(rowb,        i) = col
  1903.       tmpshp(vsize-rowb+1,i) = col
  1904.       tmpshp(rowb,        j) = colm
  1905.       tmpshp(vsize-rowb+1,j) = colm
  1906.       END
  1907.  
  1908.       SUBROUTINE mkrect (a,b,hs,vs,i,j)
  1909.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1910.      real temper (1:79,1:79)
  1911.      integer tmpshp(1:79,1:8)
  1912.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1913.       integer row,a,b,hs,vs,i,j
  1914.  
  1915.       do 40 row = b,b+vs-1
  1916.      tmpshp(row,i) = a
  1917.      tmpshp(row,j) = a+hs-1
  1918. 40    continue
  1919.       END
  1920.  
  1921.       SUBROUTINE mkwall
  1922.       intrinsic abs
  1923.       common /shpctl/ shape,size,vsize,inshp,insize,ivsize,
  1924.      +       thick,hthick,vthick,square,circle,rctngl,solid,skewed
  1925.      integer shape,size,vsize,inshp,insize,ivsize,
  1926.      +       thick,hthick,vthick,square,circle,rctngl
  1927.      logical solid, skewed
  1928.       common /temp/ temper,tmpshp,els,wlb,wle,ils,irs,wrb,wre,ers
  1929.      real temper (1:79,1:79)
  1930.      integer tmpshp(1:79,1:8)
  1931.      integer els,wlb,wle,ils,irs,wrb,wre,ers
  1932.       integer row,midrow,diff
  1933.  
  1934.       midrow = (vsize+1)/2
  1935.       do 50 row = 2, vsize-1
  1936.      diff = tmpshp(row,els)-tmpshp(row-1,els)
  1937.      IF (diff)10,20,30
  1938. 10       continue
  1939.         tmpshp(row,wlb) = tmpshp(row-1,els)
  1940.         tmpshp(row,wre) = tmpshp(row-1,ers)
  1941.         GO TO 40
  1942. 20       continue
  1943.         tmpshp(row,wlb) = tmpshp(row,els)+1
  1944.         tmpshp(row,wre) = tmpshp(row,ers)-1
  1945.         GO TO 40
  1946. 30       continue
  1947.         tmpshp(row,wlb) = tmpshp(row+1,els)
  1948.         tmpshp(row,wre) = tmpshp(row+1,ers)
  1949.         GO TO 40
  1950. 40       continue
  1951.      IF (tmpshp(row,ils) .eq. 0) THEN
  1952.         tmpshp(row,irs) = 0
  1953.         tmpshp(row,wle) = 0
  1954.         tmpshp(row,wrb) = 0
  1955.      ELSE
  1956.         tmpshp(row,wle) = tmpshp(row,ils)-1
  1957.         tmpshp(row,wrb) = tmpshp(row,irs)+1
  1958.      END IF
  1959. 50    continue
  1960.       END                    
  1961.  
  1962.       SUBROUTINE NOP
  1963.       END
  1964.  
  1965.       SUBROUTINE ClrScr
  1966.       write (*,10) '1'
  1967. 10    format (a1)
  1968. *      print '(''1'')'
  1969.       END
  1970.  
  1971.       SUBROUTINE PrEntr
  1972.       Print *, 'Press Enter to Continue'
  1973.       Read *
  1974.       END
  1975.  
  1976.